home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / connec1r / usercont.ctl < prev   
Text File  |  1999-07-10  |  8KB  |  241 lines
  1. VERSION 5.00
  2. Begin VB.UserControl UserControl1 
  3.    ClientHeight    =   615
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   675
  7.    ScaleHeight     =   615
  8.    ScaleWidth      =   675
  9. End
  10. Attribute VB_Name = "UserControl1"
  11. Attribute VB_GlobalNameSpace = False
  12. Attribute VB_Creatable = True
  13. Attribute VB_PredeclaredId = False
  14. Attribute VB_Exposed = False
  15. Option Explicit
  16.  
  17. ' XLinkLabel
  18. ' Author: David Crowell (davidc@qtm.net)
  19. ' See http://www.qtm.net/~davidc for updates
  20. ' Released to the public domain
  21. '
  22. ' Last update: May 22, 1999
  23. '
  24. ' Use this code at your own risk.  I assume no liability for
  25. ' the use of this code.
  26. '
  27. ' The purpose of XLinkLabel is to have a label control
  28. ' that works as a hyperlink.
  29. '
  30.  
  31. ' API Declares
  32. Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
  33. Private Declare Function ReleaseCapture Lib "user32" () As Long
  34. Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
  35. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  36.  
  37. ' Module level variables
  38. Private nControlHeight As Long
  39. Private nControlWidth As Long
  40. Private bHovering As Boolean
  41.  
  42. ' Property member variables
  43. Private mBackColor As OLE_COLOR
  44. Private mNormTextColor As OLE_COLOR
  45. Private mHoverTextColor As OLE_COLOR
  46. Private mNormUnderline As Boolean
  47. Private mHoverUnderline As Boolean
  48. Private mFont As StdFont
  49. Private mCaption As String
  50. Private mURL As String
  51. Private mEnabled As Boolean
  52.  
  53. ' The property Get/Let/Set stuff if pretty
  54. ' self-explanatory, so figure it out :)
  55.  
  56. Public Property Get BackColor() As OLE_COLOR
  57.     BackColor = mBackColor
  58. End Property
  59. Public Property Let BackColor(NewColor As OLE_COLOR)
  60.     mBackColor = NewColor
  61.     UserControl.BackColor = mBackColor
  62.     UserControl_Paint
  63.     PropertyChanged "BackColor"
  64. End Property
  65.  
  66. Public Property Get NormTextColor() As OLE_COLOR
  67.     NormTextColor = mNormTextColor
  68. End Property
  69. Public Property Let NormTextColor(NewColor As OLE_COLOR)
  70.     mNormTextColor = NewColor
  71.     UserControl.ForeColor = NewColor
  72.     UserControl_Paint
  73.     PropertyChanged "NormTextColor"
  74. End Property
  75.  
  76. Public Property Get HoverTextColor() As OLE_COLOR
  77.     HoverTextColor = mHoverTextColor
  78. End Property
  79. Public Property Let HoverTextColor(NewColor As OLE_COLOR)
  80.     mHoverTextColor = NewColor
  81.     UserControl_Paint
  82.     PropertyChanged "HoverTextColor"
  83. End Property
  84.  
  85. Public Property Get NormUnderline() As Boolean
  86.     NormUnderline = mNormUnderline
  87. End Property
  88. Public Property Let NormUnderline(val As Boolean)
  89.     mNormUnderline = val
  90.     UserControl.FontUnderline = val
  91.     UserControl_Paint
  92.     PropertyChanged "NormUnderline"
  93. End Property
  94.  
  95. Public Property Get HoverUnderline() As Boolean
  96.     HoverUnderline = mHoverUnderline
  97. End Property
  98. Public Property Let HoverUnderline(val As Boolean)
  99.     mHoverUnderline = val
  100.     UserControl_Paint
  101.     PropertyChanged "HoverUnderline"
  102. End Property
  103.  
  104. Public Property Get Font() As StdFont
  105.     Set Font = mFont
  106. End Property
  107. Public Property Set Font(NewFont As StdFont)
  108.     Set mFont = NewFont
  109.     Set UserControl.Font = mFont
  110.     UserControl_Paint
  111.     PropertyChanged "Font"
  112. End Property
  113.  
  114. Public Property Get Caption() As String
  115.     Caption = mCaption
  116. End Property
  117. Public Property Let Caption(val As String)
  118.     mCaption = val
  119.     UserControl_Paint
  120.     PropertyChanged "Caption"
  121. End Property
  122.  
  123. Public Property Get URL() As String
  124.     URL = mURL
  125. End Property
  126. Public Property Let URL(val As String)
  127.     mURL = val
  128.     PropertyChanged "URL"
  129. End Property
  130.  
  131. Public Property Get Enabled() As Boolean
  132.     Enabled = mEnabled
  133. End Property
  134. Public Property Let Enabled(val As Boolean)
  135.     mEnabled = val
  136.     UserControl.Enabled = val
  137.     PropertyChanged "Enabled"
  138. End Property
  139.  
  140. ' set up the default values
  141. Private Sub UserControl_InitProperties()
  142.     Set Font = Ambient.Font
  143.     BackColor = Ambient.BackColor
  144.     NormTextColor = Ambient.ForeColor
  145.     HoverTextColor = Ambient.ForeColor
  146.     URL = "http://www.qtm.net/~davidc" ' got to put my plug in here :)
  147.     Enabled = True
  148.     Caption = UserControl.Extender.Name
  149.     NormUnderline = False
  150.     HoverUnderline = True
  151. End Sub
  152.  
  153. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  154. ' Read saved properties
  155.     On Error Resume Next
  156.     Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  157.     BackColor = PropBag.ReadProperty("BackColor", Ambient.BackColor)
  158.     NormTextColor = PropBag.ReadProperty("NormTextColor", Ambient.ForeColor)
  159.     HoverTextColor = PropBag.ReadProperty("HoverTextColor", Ambient.ForeColor)
  160.     URL = PropBag.ReadProperty("URL", "http://www.qtm.net/~davidc")
  161.     Enabled = PropBag.ReadProperty("Enabled", True)
  162.     Caption = PropBag.ReadProperty("Caption", "URL Label")
  163.     NormUnderline = PropBag.ReadProperty("NormUnderline", False)
  164.     HoverUnderline = PropBag.ReadProperty("HoverUnderline", True)
  165. End Sub
  166.  
  167. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  168. ' Write properties (used only during design time)
  169.     PropBag.WriteProperty "Font", Font
  170.     PropBag.WriteProperty "BackColor", BackColor, Ambient.BackColor
  171.     PropBag.WriteProperty "NormTextColor", NormTextColor, Ambient.ForeColor
  172.     PropBag.WriteProperty "HoverTextColor", HoverTextColor, Ambient.ForeColor
  173.     PropBag.WriteProperty "URL", URL, "http://www.qtm.net/~davidc"
  174.     PropBag.WriteProperty "Enabled", Enabled, True
  175.     PropBag.WriteProperty "Caption", Caption, "URL Label"
  176.     PropBag.WriteProperty "NormUnderline", NormUnderline, False
  177.     PropBag.WriteProperty "HoverUnderline", HoverUnderline, True
  178. End Sub
  179.  
  180. Private Sub UserControl_Resize()
  181.  
  182.     ' Store the size of the usercontrol for faster use later
  183.     nControlHeight = UserControl.Height
  184.     nControlWidth = UserControl.Width
  185.     
  186. End Sub
  187.  
  188. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  189.     
  190.     Dim bHover As Boolean
  191.     
  192.     ' Always call release capture
  193.     Call ReleaseCapture
  194.     
  195.     ' Is the mouse over the control?
  196.     If (X < 0) Or (Y < 0) Or (X > nControlWidth) Or (Y > nControlHeight) Then
  197.         bHover = False
  198.     Else
  199.         bHover = True
  200.         ' if so be sure to call SetCapture, so we'll catch it when it moves off
  201.         Call SetCapture(UserControl.hWnd)
  202.     End If
  203.     
  204.     If bHovering <> bHover Then
  205.     ' only change appearance if necessary
  206.         bHovering = bHover
  207.         
  208.         ' we change the font setting of the usercontrol
  209.         ' which will take effect next time we repaint
  210.         If bHovering Then
  211.             UserControl.FontUnderline = mHoverUnderline
  212.             UserControl.ForeColor = mHoverTextColor
  213.         Else
  214.             UserControl.FontUnderline = mNormUnderline
  215.             UserControl.ForeColor = mNormTextColor
  216.         End If
  217.         
  218.         ' repaint
  219.         UserControl_Paint
  220.         
  221.     End If
  222.     
  223. End Sub
  224.  
  225. Private Sub UserControl_Paint()
  226.  
  227.     ' erase current contents
  228.     UserControl.Cls
  229.     
  230.     ' and repaint the text
  231.     Call TextOut(UserControl.hDC, 0, 0, mCaption, Len(mCaption))
  232.     
  233. End Sub
  234.  
  235. Private Sub UserControl_Click()
  236. ' Open the default browser with the URL
  237.  
  238.     Call ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)
  239.     
  240. End Sub
  241.